home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / MOTION.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  7.4 KB  |  224 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;;; Motion within Groups
  43.  
  44. ;;;; Mark Movement
  45.  
  46. (begin
  47. (define-integrable group-start
  48.   (lambda (mark)
  49.     (%group-start (mark-group mark))))
  50.  
  51. (define-integrable group-end
  52.   (lambda (mark)
  53.     (%group-end (mark-group mark))))
  54. )
  55. (define (group-start? mark)
  56.   (mark= (group-start mark) mark))
  57.  
  58. (define (group-end? mark)
  59.   (mark= (group-end mark) mark))
  60.  
  61. (define (line-start? mark)
  62.   (or (group-start? mark)
  63.       (zero? (mark-position mark))))
  64.  
  65. (define (line-end? mark)
  66.   (or (group-end? mark)
  67.       (= (mark-position mark) (line-length (mark-line mark)))))
  68.  
  69. (define (limit-mark-motion limit? limit)
  70.   (cond ((eq? limit? 'LIMIT) limit)
  71.     ((eq? limit? 'BEEP) (beep) limit)
  72.     ((eq? limit? 'ERROR) (editor-error))
  73.     ((not limit?) #F)
  74.     (else (error "Unknown limit type" limit?))))
  75.  
  76. (define (mark1+ mark limit?)
  77.   (cond ((group-end? mark)
  78.      (limit-mark-motion limit? mark))
  79.     ((= (mark-position mark)
  80.         (line-length (mark-line mark)))
  81.      (make-mark (line-next (mark-line mark))
  82.             0))
  83.     (else
  84.      (make-mark (mark-line mark)
  85.             (1+ (mark-position mark))))))
  86.  
  87. (define (mark-1+ mark limit?)
  88.   (cond ((group-start? mark)
  89.      (limit-mark-motion limit? mark))
  90.     ((zero? (mark-position mark))
  91.      (make-mark (line-previous (mark-line mark))
  92.             (line-length (line-previous (mark-line mark)))))
  93.     (else
  94.      (make-mark (mark-line mark)
  95.             (-1+ (mark-position mark))))))
  96.  
  97. (define (mark+ mark n limit?)
  98.   (cond ((positive? n)
  99.      (let ((end-mark (group-end mark)))
  100.        (let ((end-line (mark-line end-mark))
  101.          (end-position (mark-position end-mark)))
  102.          (define (loop line position n)
  103.            (if (eq? line end-line)
  104.            (let ((new-position (+ position n)))
  105.              (if (<= new-position end-position)
  106.              (make-mark line new-position)
  107.              (limit-mark-motion limit? end-mark)))
  108.            (let ((room (- (line-length line) position)))
  109.              (if (<= n room)
  110.              (make-mark line (+ position n))
  111.              (loop (line-next line) 0 (- n (1+ room)))))))
  112.          (loop (mark-line mark) (mark-position mark) n))))
  113.     ((negative? n) (mark- mark (- n) limit?))
  114.     (else mark)))
  115.  
  116. (define (mark- mark n limit?)
  117.   (cond ((positive? n)
  118.      (let ((start-mark (group-start mark)))
  119.        (let ((start-line (mark-line start-mark))
  120.          (start-position (mark-position start-mark)))
  121.          (define (loop line position n)
  122.            (cond ((eq? line start-line)
  123.               (let ((new-position (- position n)))
  124.             (if (<= start-position new-position)
  125.                 (make-mark line new-position)
  126.                 (limit-mark-motion limit? start-mark))))
  127.              ((<= n position)
  128.               (make-mark line (- position n)))
  129.              (else
  130.               (loop (line-previous line)
  131.                 (line-length (line-previous line))
  132.                 (- n (1+ position))))))
  133.          (loop (mark-line mark) (mark-position mark) n))))
  134.     ((negative? n) (mark+ mark (- n) limit?))
  135.     (else mark)))
  136.  
  137. (define (region-count-chars region)
  138.   (region-components region
  139.     (lambda (start-line start-position end-line end-position)
  140.       (define (loop line accumulator)
  141.     (if (eq? line end-line)
  142.         (+ end-position accumulator)
  143.         (loop (line-next line)
  144.           (1+ (+ (line-length line) accumulator)))))
  145.       (if (eq? start-line end-line)
  146.       (- end-position start-position)
  147.       (loop (line-next start-line)
  148.         (1+ (- (line-length start-line) start-position)))))))
  149.  
  150. ;;;; Mark Comparison
  151.  
  152. (define (mark= mark1 mark2)
  153.   (and (eq? (mark-line mark1) (mark-line mark2))
  154.        (= (mark-position mark1) (mark-position mark2))))
  155.  
  156. (define (mark< mark1 mark2)
  157.   (if (eq? (mark-line mark1) (mark-line mark2))
  158.       (< (mark-position mark1) (mark-position mark2))
  159.       (and (eq? (line-group (mark-line mark1))
  160.         (line-group (mark-line mark2)))
  161.        (< (line-number (mark-line mark1))
  162.           (line-number (mark-line mark2))))))
  163.  
  164. (define (mark<= mark1 mark2)
  165.   (if (eq? (mark-line mark1) (mark-line mark2))
  166.       (<= (mark-position mark1) (mark-position mark2))
  167.       (and (eq? (line-group (mark-line mark1))
  168.         (line-group (mark-line mark2)))
  169.        (< (line-number (mark-line mark1))
  170.           (line-number (mark-line mark2))))))
  171.  
  172. (define (mark> mark1 mark2)
  173.   (if (eq? (mark-line mark1) (mark-line mark2))
  174.       (> (mark-position mark1) (mark-position mark2))
  175.       (and (eq? (line-group (mark-line mark1))
  176.         (line-group (mark-line mark2)))
  177.        (> (line-number (mark-line mark1))
  178.           (line-number (mark-line mark2))))))
  179.  
  180.  
  181. ;;;; Line Movement
  182.  
  183. (define (line-offset line n if-ok if-not-ok)
  184.   (cond ((negative? n)
  185.      (let ((limit (mark-line (%group-start (line-group line)))))
  186.        (define (loop- line n)
  187.          (cond ((zero? n) (if-ok line))
  188.            ((eq? line limit) (if-not-ok limit))
  189.            (else (loop- (line-previous line) (1+ n)))))
  190.        (if (eq? line limit)
  191.            (if-not-ok limit)
  192.            (loop- (line-previous line) (1+ n)))))
  193.     (else
  194.      (let ((limit (mark-line (%group-end (line-group line)))))
  195.        (define (loop+ line n)
  196.          (cond ((zero? n) (if-ok line))
  197.            ((eq? line limit) (if-not-ok limit))
  198.            (else (loop+ (line-next line) (-1+ n)))))
  199.        (loop+ line n)))))
  200.  
  201. (define (line-start mark n limit?)
  202.   (line-offset (mark-line mark) n
  203.            (lambda (line)
  204.          (if (eq? line (mark-line (group-start mark)))
  205.              (group-start mark)
  206.              (make-mark line 0)))
  207.            (lambda (line)
  208.          (limit-mark-motion limit?
  209.                     (if (negative? n)
  210.                     (group-start mark)
  211.                     (group-end mark))))))
  212.  
  213. (define (line-end mark n limit?)
  214.   (line-offset (mark-line mark) n
  215.            (lambda (line)
  216.          (if (eq? line (mark-line (group-end mark)))
  217.              (group-end mark)
  218.              (make-mark line (line-length line))))
  219.            (lambda (line)
  220.          (limit-mark-motion limit?
  221.                     (if (negative? n)
  222.                     (group-start mark)
  223.                     (group-end mark))))))
  224.